home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 1 / Gold Medal Software Volume 1 (Gold Medal) (1994).iso / prog / tpwprog6.arj / DYNAICON.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-07-02  |  4.3 KB  |  172 lines
  1. { dynaicon.pas -- Display an animated icon guage }
  2.  
  3. program DynaIcon;
  4.  
  5. uses WinTypes, WinProcs, WObjects;
  6.  
  7. const
  8.  
  9.   timer_ID  = 1;          { Local timer id number }
  10.   timer_Interval = 500;   { Milliseconds between timer events }
  11.   level_Increment = 16;   { Number of gauge increments }
  12.  
  13. type
  14.  
  15.   DynaIconApplication = object(TApplication)
  16.     procedure InitMainWindow; virtual;
  17.   end;
  18.  
  19.   PDynaIconWindow = ^DynaIconWindow;
  20.   DynaIconWindow = object(TWindow)
  21.     Level: Integer;
  22.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  23.     procedure GetGaugeRect(var R: TRect;
  24.       var Increment: Integer);
  25.     procedure GetWindowClass(var AWndClass: TWndClass);
  26.       virtual;
  27.     procedure SetupWindow;
  28.       virtual;
  29.     procedure WMDestroy(var Msg: TMessage);
  30.       virtual wm_First + wm_Destroy;
  31.     procedure WMTimer(var Msg: TMessage);
  32.       virtual wm_First + wm_Timer;
  33.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  34.       virtual;
  35.   end;
  36.  
  37.  
  38. { DynaIconApplication }
  39.  
  40. {- Initialize DynaIconApplication object's window }
  41. procedure DynaIconApplication.InitMainWindow;
  42. begin
  43.   MainWindow := New(PDynaIconWindow, Init(nil, 'DynaIcon'))
  44. end;
  45.  
  46.  
  47. { DynaIconWindow }
  48.  
  49. {- Construct DynaIconWindow object }
  50. constructor DynaIconWindow.Init(AParent: PWindowsObject; ATitle: PChar);
  51. begin
  52.   TWindow.Init(AParent, ATitle);
  53.   Level := 0
  54. end;
  55.  
  56. {- Modify window class to generate wm_Paint messages for icon }
  57. procedure DynaIconWindow.GetWindowClass(var AWndClass: TWndClass);
  58. begin
  59.   TWindow.GetWindowClass(AWndClass);
  60.   AWndClass.HIcon := 0
  61. end;
  62.  
  63. {- Initialize the window's actions }
  64. procedure DynaIconWindow.SetupWindow;
  65. begin
  66.   TWindow.SetupWindow;
  67.   SetTimer(hWindow, timer_ID, timer_Interval, nil)
  68. end;
  69.  
  70. {- Intercept wm_Destroy message }
  71. procedure DynaIconWindow.WMDestroy(var Msg: TMessage);
  72. begin
  73.   KillTimer(hWindow, timer_ID);
  74.   TWindow.WMDestroy(Msg)
  75. end;
  76.  
  77. {- Calculate gauge rectangle }
  78. procedure DynaIconWindow.GetGaugeRect(var R: TRect;
  79.   var Increment: Integer);
  80. begin
  81.   GetClientRect(HWindow, R);
  82.   with R do
  83.   begin
  84.     if not IsIconic(HWindow) then
  85.     begin
  86.       Left := Left + 10;
  87.       Top := Top + 10;
  88.       Right := Right - 10;
  89.       Bottom := Top + 20;
  90.       while (Right - Left) mod level_Increment <> 0 do
  91.         Dec(Right)
  92.     end;
  93.     Increment := (Right - Left) div level_Increment;
  94.     if Increment <= 0 then Increment := 0
  95.   end
  96. end;
  97.  
  98. {- Execute one "tick" of the timer's clock }
  99. procedure DynaIconWindow.WMTimer(var Msg: TMessage);
  100. var
  101.   R: TRect;
  102.   N: Integer;
  103. begin
  104.   GetGaugeRect(R, N);
  105.   if Level >= level_Increment then
  106.   begin  { Reset Level, causing entire gauge to be redrawn }
  107.     MessageBeep(0);
  108.     Level := 0
  109.   end else
  110.   begin  { Count passes and calculate gauge area to redraw }
  111.     Inc(Level);
  112.     with R do
  113.     begin
  114.       Right := Left + Level * N;
  115.       Left := Left + (Level - 1) * N
  116.     end
  117.   end;
  118.   InvalidateRect(HWindow, @R, false) { Redraw TRect bounded by R }
  119. end;
  120.  
  121. {- Paint demonstration gauge }
  122. procedure DynaIconWindow.Paint(PaintDC: HDC; var PaintInfo:
  123.   TPaintStruct);
  124. var
  125.   R: TRect;
  126.   I, N, X: Integer;
  127.   Brush, OldBrush: HBrush;
  128.   Pen, OldPen: HPen;
  129. begin
  130.   Brush := GetStockObject(white_Brush);
  131.   OldBrush := SelectObject(PaintDC, Brush);
  132.   Pen := GetStockObject(black_Pen);
  133.   OldPen := SelectObject(PaintDC, Pen);
  134.   GetGaugeRect(R, N);
  135.   with R do
  136.   begin
  137.     Rectangle(PaintDC, Left, Top, Right, Bottom); { Outline }
  138.     for I := 1 to level_Increment do
  139.     begin
  140.       X := Left + I * N;
  141.       if (not IsIconic(HWindow)) and (I < level_Increment) then
  142.       begin
  143.         MoveTo(PaintDC, X, Top - 2);    { Division lines }
  144.         LineTo(PaintDC, X, Bottom + 2)
  145.       end;
  146.       if I <= Level then  { Paint filled areas }
  147.       begin
  148.         SelectObject(PaintDC, GetStockObject(black_Brush));
  149.         Rectangle(PaintDC, Left + (I - 1) * N, Top, X, Bottom)
  150.       end
  151.     end
  152.   end;
  153.   SelectObject(PaintDC, OldBrush);
  154.   SelectObject(PaintDC, OldPen)
  155. end;
  156.  
  157. var
  158.  
  159.   DynaIconApp: DynaIconApplication;
  160.  
  161. begin
  162.   DynaIconApp.Init('DynaIconApp');
  163.   DynaIconApp.Run;
  164.   DynaIconApp.Done
  165. end.
  166.  
  167.  
  168. {--------------------------------------------------------------
  169.   Copyright (c) 1991 by Tom Swan. All rights reserved.
  170.   Revision 1.00    Date: 3/07/1991
  171. ---------------------------------------------------------------}
  172.